{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  P5Hs.Language.Pretty
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Pretty print.
-- 
--------------------------------------------------------------------------------

module P5Hs.Language.Pretty
 
  where

import P5Hs.Language.Syntax

import Text.PrettyExprHPJ hiding (Unary, Binary)    -- package: pretty-expr-hpj
import Text.PrettyExprHPJ.Java

import Text.PrettyPrint.HughesPJ                -- package: pretty

import Numeric




-- | (14) const exp
--
expr :: Expr -> Doc
expr = unparse . exprDoc


exprDoc :: Expr -> DocE
exprDoc (Value v)               = valueDocE v
exprDoc (VarId v)               = Atom $ text v
exprDoc (Unary op e)            = unaryDocE op (exprDoc e)
exprDoc (Binary op e1 e2)       = binDocE op (exprDoc e1) (exprDoc e2) 

valueDocE :: Value -> DocE 
valueDocE (Int i)               = Atom $ integer i
valueDocE (Float d)             = Atom $ truncDouble $ realToFrac d
valueDocE (Double d)            = Atom $ truncDouble $ realToFrac d
valueDocE (String s)            = Atom $ stringLiteral s
valueDocE (Colour c)            = Atom $ colour c


unaryDocE :: UnaryOp -> DocE -> DocE
unaryDocE LOGICAL_NOT   = logicalNotU
unaryDocE UPLUS         = plusU
unaryDocE UMINUS        = minusU


binDocE :: BinOp -> DocE -> DocE -> DocE
binDocE ADDITION        = addB 
binDocE MINUS           = subtractB 
binDocE MULTIPLY        = multiplyB
binDocE DIVIDE          = divideB
binDocE MODULO          = moduloB
binDocE LOGICAL_AND     = logicalAndB
binDocE LOGICAL_OR      = logicalOrB 



colour :: Colour -> Doc
colour (RGB r g b)      = funcall "color" [r,g,b]
colour (RGBA r g b a)   = funcall "color" [r,g,b,a]
colour (Gray gy)        = funcall "color" [gy]
colour (GrayA gy a)     = funcall "color" [gy,a]


{-
            | RGBA  Expr Expr Expr Expr
            | Gray  Expr
            | GrayA Expr Expr
-}

funcall :: String -> [Expr] -> Doc
funcall name es = text name <> parens (commaSep $ map expr es)

--------------------------------------------------------------------------------
-- Helpers

truncDouble :: Double -> Doc
truncDouble = text . truncatedDouble


showFFloat_ :: RealFloat a => a -> String
showFFloat_ = ($ "") . showFFloat Nothing


-- | Truncate the printed decimal representation of a Double.
-- This may be prefered to 'showFFloat' from Numeric as it 
-- produces shorter representations when the value has trailing
-- zeros.
-- 
-- 0.000000000 becomes 0.0 rather than however many digits are 
-- specified.
--  
truncatedDouble :: Double -> String
truncatedDouble d 
    | abs d < 0.0001  = "0.0"
    | d < 0.0         = '-' :  showFFloat_ (abs tx)
    | otherwise       = showFFloat_ tx
  where
    tx :: Double
    tx = (realToFrac (roundi (d*1000000.0))) / 1000000.0

roundi :: RealFrac a => a -> Integer
roundi = round




stringLiteral :: String -> Doc
stringLiteral s = text $ '"' : s ++ ['"']

charLiteral :: Char -> Doc
charLiteral c = text $ [ '\'', c, '\'']

angles :: Doc -> Doc
angles p       = char '<' <> p <> char '>'


catWith :: [Doc] -> Doc -> Doc
catWith ds sp = hcat $ punctuate sp ds

sepWith :: [Doc] -> Doc -> Doc
sepWith ds sp = hsep $ punctuate sp ds

maybeSpaced :: Maybe Doc -> Doc
maybeSpaced (Just d)  = empty <+> d
maybeSpaced (Nothing) = empty


commaCat :: [Doc] -> Doc
commaCat = catWith `flip` comma

commaSep :: [Doc] -> Doc
commaSep = sepWith `flip` comma


sepEndBy :: [Doc] -> Doc -> Doc
sepEndBy ds sp = hsep $ map (<> sp) ds


